;;########################################################################
;; dashobj3.lsp
;; Copyright (c) 1994-2002 by Forrest W. Young
;;
;; REDRAW METHODS
;;
;;########################################################################



(defmeth datasheet-proto :redraw-content ()
  (send self :redraw-datasheet-content))

(defmeth datasheet-proto :redraw-datasheet-content ()
  (when *vista-exists*
  (when (send self :redraw-now)
  (when (send *vista* :ready-to-redraw self);fwy 4.31 10/30/97
  (let* ((dob (send self :data-object))
         ;(type-abbrev (data-type-abbreviation (send dob :determine-data-type)))
         (numvar (send self :nvar))
         (numobs (send self :nobs))
         (send self :datatype-string (second (datatype? dob t t)))
         (str1 (send self :datatype-string))
         (send self :datasize-string (format nil "[~d X ~d]" numobs numvar))
         (str2 (send self :datasize-string))
         (fw (send self :field-width ))  
         (fh (send self :field-height)) ;datum field height
         (lw (send self :label-width ))
         (hh (* 2 fh))                  ;header field height
#+macintosh (cw 6)                      ;character width
#-macintosh (cw 8)                      ;character width
         (nc (send self :number-of-columns))
         (yloc nil)
         (xloc nil)
         (text nil)
         (types (send self :type-strings))
         (matst (send self :data-matrix-strings))
         (editable (send self :editable))
         (hot-cell (send self :hot-cell))
         (vr (send self :view-rect))
         (x+ (send self :x+)) 
         (y+ (send self :y+))
         (minx (first vr))
         (miny (second vr))
         (maxx (+ minx (third vr)))
         (maxy (+ miny (fourth vr)))
         (mino (max (floor (/ (- miny hh) fh)) 0))
         (minv (max (floor (/ (- minx lw) fw)) 0)) 
         (maxo (min (floor (/ (- maxy hh) fh)) (1- numobs)))
         (maxv (min (floor (/ (- maxx lw) fw)) (1- numvar)))
         ) 
    (when (and (<= mino maxo) (<= minv maxv))
          (send self :start-buffering)
          (send self :line-type 'solid)

;heavy top border
          (when (= miny 0)
                (send self :line-width 2)
                (send self :draw-line (+ x+ -1 (max 0 minx)) (1- y+)
                      (+ x+ 1 (min maxx (+ lw (* numvar fw)))) (1+ y+)))


;colored top rectangle 
          (when (< miny hh)
                (send self :draw-color 'light-yellow)
                (send self :paint-rect
                      (+ x+ (max minx 0)) (+ y+ miny)
                      (- (+ (min maxx (+ lw (* numvar fw)))) (+ (max minx 0)))
                      (if (< miny fh) hh fh))
                (send self :draw-color 'black)
                )

;heavy line between labels and body - colored left rectangle          
          (when (< minx lw maxx)
                (send self :draw-color 'light-yellow)
                (send self :paint-rect
                      x+ (+ y+ (max miny 0))
                      lw (- (+ (min maxy (* (+ 2 numobs) fh))) (max miny 0)))
                (send self :draw-color 'black)
                (send self :line-width 2)
                (send self :draw-line (+ x+ lw) (+ y+  (max miny 0))
                      (+ x+ lw) (+ y+ (min maxy (* (+ 2 numobs) fh)))))

;heavy line between vartypes and body and between top and body
          (when (< miny hh)
                (send self :line-width 2)
                (send self :draw-line  
                      (+ x+ (max minx 0)) y+ (+ x+ (min maxx (+ lw (* numvar fw)))) y+)
                (send self :draw-line  
                      (+ x+ (max minx 0)) (+ y+ hh )
                      (+ x+ (min maxx (+ lw (* numvar fw))))  (+ y+ hh)))

;horizontal line between varname-vartype
          (when (< miny fh)
                (send self :line-width 2)
                (send self :draw-line 
                      (+ x+ (max lw minx)) (+ y+ fh )
                      (+ x+ (min maxx (+ lw (* numvar fw)))) (+ y+ fh)))

;bottom border
          (when (> maxy (* (+ 2 numobs) fh))
                (send self :line-width 2)
                (send self :draw-line 
                      (+ x+ (max minx 0)) 
                      (+ y+ (* (+ 2 numobs) fh))
                      (+ x+ (min maxx (+ lw (* numvar fw)))) 
                      (+ y+ (* (+ 2 numobs) fh))))

;right border
          (when (> maxx (+ lw (* numvar fw)))
                (send self :line-width 2)
                (send self :draw-line 
                      (+ x+ lw (* numvar fw)) (+ y+ (max 0 miny))
                      (+ x+ lw (* numvar fw)) (+ y+ (min maxy (* (+ 2 numobs) fh)))))

;header: vertical lines, var names and types
          (send self :line-width 1)
          (when (< miny hh maxy)
                (dolist (i (iseq minv maxv))
                        (send self :draw-line 
                              (+ x+ lw (* (+ i 1) fw)) (+ y+ miny)
                              (+ x+ lw (* (+ i 1) fw)) (+ y+ hh))
                        (when (< miny fh)
                              (send self :draw-text 
                                    (subseq 
                                     (select (send self :variable-strings) i) 0 
                                     (min (floor (/ fw cw));6
                                          (length (select (send self :variable-strings) i))))
                                    (+ x+ lw (* fw i) (floor (/ fw 2))) (+ y+ (- fh 3)) 1 0))
                        (send self :draw-text 
                              (subseq 
                               (select (send self :type-strings) i) 0
                               (min (floor (/ fw cw));6
                                    (length (select (send self :type-strings) i))))
                              (+ x+ lw (* fw i) (floor (/ fw 2))) 
                              (+ y+ (- (* 2 fh) 3)) 1 0)))

;upper corner diagonal line and var and obs values
          (when (and (< minx lw maxx) (< miny hh maxy))
                (when (< miny fh)
                      ; this code draws data-type on top line
                      ; and obs X vars on next line
                      ; with a horizontal dashed line
                      (send self :draw-color 'light-yellow)
                      (send self :paint-rect x+ (+ y+ 1) (+ x+ lw (- 2)) (- hh 2))
                      (send self :draw-color 'black)
                      (send self :line-type 'dashed)
                      (send self :draw-line x+ (+ y+ fh) (+ x+ lw (- 1)) (+ y+ fh))
                      (send self :line-type 'solid)
                      (send self :draw-text str1 (+ x+ 3) (+ y+ (- fh 3)) 0 0)
                      ;(send self :draw-line x+ y+ (+ x+ lw) (+ y+ hh))
                      ;(send self :draw-text (format nil "~d Vars" numvar)
                      ;      (+ x+ (- lw 4)) (+ y+ (- fh 3)) 2 0)
                      )
                ;(send self :draw-text (format nil "~d Obs" numobs) 
                ;      (+ x+ 3) (+ y+ (- (* 2 fh) 3)) 0 0)
                )
          (send self :draw-text str2 (+ x+ 3) (+ y+ (- (* 2 fh) 4)) 0 0)
          
          (send self :line-type 'dashed)
    
;dashed lines in body
          (send self :line-width 1)
          (dotimes (i (- numobs 1))
                   (when (< miny (* (+ i 3) fh) maxy)
                         (send self :draw-line 
                               (+ x+ (max minx 0)) (+ y+ (* (+ i 3) fh) )
                               (+ x+ (min maxx (+ lw (* numvar fw))) )
                               (+ y+ (* (+ i 3) fh))))) ;between obs
          (dotimes (i (- numvar 1))
                   (when (< minx (+ lw (* (+ i 1) fw)) maxx)
                         (send self :draw-line 
                               (+ x+ lw (* (+ i 1) fw)) (+ y+ (max miny hh))
                               (+ x+ lw (* (+ i 1) fw)) (+ y+ (min maxy (* (+ 2 numobs) fh))))))



;left border
          (when (= minx 0)
                (send self :line-width 2)
                (send self :draw-line  x+  (+ y+ (max 0 miny))
                      x+ (+ y+ (min maxy (* (+ 2 numobs) fh))))
                 )

;draw labels and data
          (dolist (i (iseq mino maxo)) 
                  (setf yloc (+ y+ (* 3 fh) (- (* i fh) 3))) 
                  (send self :draw-text (select (send self :label-strings) i)
                        (+ x+ 3) yloc 0 0)
                  (dolist (j (iseq minv maxv)) 
                          (setf xloc (+ x+ (- (+ lw (* (+ 1 j) fw)) 3)))
                          (if (> (- fw cw) (send self :text-width (aref matst i j)));6
                              (send self :draw-text (aref matst i j) xloc yloc 2 0)
                              (if (equal "Category" (select types j))
                                  (send self :draw-text 
                                        (subseq (aref matst i j) 0 nc) xloc yloc 2 0)
                                  (send self :draw-text 
                                        (apply #'strcat (repeat "*" nc)) 
                                        xloc yloc 2 0)))))
          (send self :line-type 'solid)
          (when editable
                (send self :line-width 2)
                (when (and (< miny fh) (not (send dob :ways)))
                      (send self :draw-color 'toolbar-background)
                      (send self :paint-rect (+ x+ lw -1 (* fw numvar)) 
                            (- y+ 2) (- fw 2) (+ 3 fh))
                      (send self :draw-color 'black)
                      (send self :frame-rect (+ x+ lw -1 (* fw numvar)) 
                            (- y+ 1) (- fw 2) (+ 2 fh))
                      (setf text "New Var")
                      (send self :draw-text text 
                            (floor (+ x+ lw (* fw (+ numvar 0.5)))) 
                            (+ y+ (- fh 3)) 1 0))
                (send self :draw-line x+  (+ y+ (* fh (+ numobs 3)))
                      (+ x+ lw) (+ y+ (* fh (+ numobs 3))))
                (send self :line-width 2)
                (send self :draw-color 'toolbar-background)
                (send self :paint-rect (+ x+ 0) (+ y+ 1 (* fh (+ numobs 2)))
                      lw (- fh 2))
                (send self :draw-color 'black)
                (send self :draw-line (+ x+ lw) (+ y+ (* fh (+ numobs 2)))
                      (+ x+ lw) (+ y+ (- (* fh (+ numobs 3)) 1)))
                (send self :line-width 1)
                (if (send dob :matrices) 
                    (setf text "New Matrix") (setf text "New Obs"))
                (send self :draw-text text (+ x+ 3) (+ y+ (- (* fh (+ numobs 3)) 3)) 0 0)
                (when hot-cell (send self :reverse-cell-color 
                                     (first hot-cell)
                                     (second hot-cell)
                                     lw fw fh
                                     (send self :hot-cell-ready)
                                     t))
                )
         
          (send self :buffer-to-screen))
    (send *vista* :finished-redraw self)
    ))
    )))


(defmeth datasheet-proto :origin (&optional (x nil x?) y)
  (when x? (send self :x+ x)
        (send self :y+ y))
  (list (send self :x+) (send self :y+)))

(defmeth datasheet-proto :click-button (button-number)
  (let* ((ovr (select (send self :overlays) 0))
         (x (+ 2 (select (send ovr :lefts) button-number)))
         (y 10)
         )
    (send ovr :do-click x y nil nil)))


(defmeth datasheet-proto :reverse-cell-color (row col lw fw fh &optional ready doclick old)
"Args: row col lw fw fh & optional ready
Reverses color of cell at intersection of col and row, where (in pixels) lw is label width, fw is field (cell) width, fh is field height. Ready indicates if cell ready for typing."
  (let ((x nil) (y nil) (w nil) (h nil) (xf 0) (yf 0)
        (x+ (send self :x+)) 
        (y+ (send self :y+))
        (nrow (send self :nobs)) (ncol (send self :nvar)))
#+macintosh(when (= 1 row) (setf yf 1))
#+macintosh(when (= 1 col) (setf xf 1))
    (when (< col 1) (setf xf (- fw lw)))
    (setf x (+ x+ lw 1 xf (* (- col 1) fw)))
    (when (< x 1) (setf x 1))
    (setf y (+ y+ 1 yf (* (+ row 1) fh)))
    (setf w (- fw 1 xf))
    (setf h (- fh 1 yf))
#-macintosh(when (or (= col 0) (= col ncol)) (setf w (1- w)))
#-macintosh(when (or (= row 0) (= row nrow)) (setf h (1- h)))
    (when (= row -1) (setf y (1- y)))
    ;(send self :draw-mode 'xor)
    (cond 
      ((and doclick (not old))
       (send self :line-width 2) 
       (send self :draw-color 'red)
      ; (send self :back-color 'blue)
       (send self :frame-rect x y w h)
       )
      (t
       (send self :line-width 2) 
       (send self :draw-color (send self :back-color))
       (send self :frame-rect x y w h)
       (send self :line-width 1)
       ))
#+macintosh(if ready
           (send self :frame-rect x y w h)
           (send self :paint-rect x y w h))
#-macintosh(send self :frame-rect x y w h)
    (send self :line-width 1)
    (send self :line-type 'solid)
    (send self :draw-color 'black)
    (send self :back-color 'white)
    ))

(defmeth datasheet-proto :cell-size-location (row col lw fw fh)
  (let ((x nil) (y nil) (w nil) (h nil) (xf nil) (yf nil) 
        (x+ (send self :x+)) 
        (y+ (send self :y+))
        )
    (if (= 1 row) (setf yf 1) (setf yf 0))
    (if (= 1 col) (setf xf 1) (setf xf 0))
    (when (< col 1) (setf xf (- fw lw)))
    (setf x (+ lw 1 xf (* (- col 1) fw)))
    (when (< x 1) (setf x 1))
    (setf y (+ 1 yf (* (+ row 1) fh)))
    (setf w (- fw 1 xf))
    (setf h (- fh 1 yf))
    (list (+ x+ x) (+ y+ y) w h)))


(defmeth datasheet-proto :set-window-size (fw fh lw nv no &optional (size-it? t))
  (let ((hor (+ 1 lw (* fw (+ 1 nv))))
        (ver (+ 1 (* fh (+ 3 no))))
        (desksize screen-size)
        )
    (send self :has-h-scroll (max hor (select (screen-size) 0)))
    (send self :has-v-scroll (max ver (select (screen-size) 1)))))


(defmeth datasheet-proto :set-scroll-bars (fw fh lw nv no)
  (let ((hor (+ 1 lw (* fw (+ 1 nv))))
        (ver (+ 1 (* fh (+ 3 no)))))
    (send self :has-h-scroll (max hor (select (screen-size) 0)))
    (send self :has-v-scroll (max ver (select (screen-size) 1)))))

(defmeth datasheet-proto :enable-vista-menus&tools 
  (&optional (logical nil set)) 
  (unless *realtime-datasheet-update*
          (when set (send current-data :set-menu&tool-states 
                          (if logical "reenable" "disabled")))
          (send self :menu-states (send *vista* :menu-states))))


(defmeth datasheet-proto :create-data-matrix-strings ()
"Message args: nil
 Creates and stores the string version of the data matrix." 
  (let* ((mat (send (send self :data-object) :data-matrix))
         (numobs (send self :nobs))
         (numvar (send self :nvar))
         (nummat (send self :nmat))
         (ndec (send self :number-of-decimals))
         (ncol (send self :number-of-columns))
         (matst (make-array (list numobs numvar)))
         (k 0)) 
    (cond 
      ((= 0 (length (send (send self :data-object) :matrices)))
       (dotimes (i numobs)
          (dotimes (j numvar)
             (setf (aref matst i j) (string-trim " " ;was string-right-trim
                   (format nil "~v,vf" ncol ndec (aref mat i j)))))))
      (t
       (send self :nobs (* numvar nummat))
       (dotimes (L nummat)
          (setf k 0)
          (dotimes (i numvar)
             (dotimes (j numvar)
                (setf (aref matst (+ i (* numvar L)) j) (string-trim " "
                      (format nil "~v,vf" ncol ndec (aref mat k L))))
                (setf k (+ k 1))))))) 
    (send self :data-matrix-strings matst))) 

(defmeth datasheet-proto :create-label-strings (data-object)
  (cond 
    ((send data-object :ways)
     (send self :label-strings (repeat (send data-object :labels) 
                                       (send data-object :cellfreqs))))
    ((send data-object :matrices)
     (send self :create-matrix-label-strings 0 (send self :nmat)))
    (t
     (send self :label-strings (copy-list (send data-object :labels))))))


(defmeth datasheet-proto :create-matrix-label-strings (nmats nmats-added)
  (dotimes (i nmats-added)
       (dotimes (j (send self :nvar))
         (send self :label-strings 
               (append (send self :label-strings) (list
                     (strcat (select (send self :matrix-strings) (+ nmats i)) 
                             ":"
                             (select (send self :variable-strings) j))))))))

(defmeth datasheet-proto :plot-help ()
  (let ((w (plot-help-window (send self :title))))
    (if (send self :editable)
        (file-to-window (strcat *help-dir-name* "editable.hlp") 
                        (send self :title) w nil)
        (file-to-window (strcat *help-dir-name* "uneditab.hlp") 
                        (send self :title) w nil))
    (paste-plot-help (format nil "~2% -----------------------~2%"))
    (paste-plot-help (format nil "ABOUT THE ~a DATA:~2%" 
                             (send (send self :data-object) :title)))
    (paste-plot-help (send (send self :data-object) :about))
    (paste-plot-help (format nil "~2%"))
    (if (> (send w :y) (second (send w :size))) 
        (send w :has-v-scroll (send w :y))
        (send w :has-v-scroll nil))))

(defmeth datasheet-proto :shrink-wrap ()
"Args: none
Determines and returns size for shrink-wrapping. Shrink wrapping done by :shrink-wrapper."
  (let* ((nvar (send self :nvar))
         (nobs (send self :nobs))
         (editable (send self :editable))
         (fw (send self :field-width))
         (fh (send self :field-height))
         (lw (send self :label-width))
         )
    (list (max 100
               (min (- (first (effective-screen-size))
                       #+macintosh  10
                        #+msdos 4
                       (first (send self :location))); 100
                    (+ 3 lw (* fw nvar) (if editable fw 0)
                       msdos-fiddle border-thickness
                       #+macintosh     window-decoration-width -3
                       )))
     (max 60
          (min (- (second (effective-screen-size))
                  #+macintosh 10
                  #+msdos 4
                  (second (send self :location)));125
               (+ msdos-fiddle 3 (* fh (+ (if editable 3 2) nobs)))
               )))))
